home *** CD-ROM | disk | FTP | other *** search
/ Grapevine 14 / Grapevine 14 (Disk 2 of 3).adf / BOTHPASCAL.S.lha / Grapevine / sources / pascal1 next >
Text File  |  1990-09-14  |  16KB  |  543 lines
  1. ____________________________________________________________________________
  2. Program Direct_Access_File_Update;
  3.  
  4. {Written by Chris Smith (THE COOKIE MONSTER OF DUAL FORMAT)
  5.          on the 2nd June 1992}
  6. uses crt;
  7. type
  8.         index = record
  9.                         reckey : integer;
  10.                         lorecno : integer;
  11.                         delflag : boolean;
  12.                 end;
  13.  
  14.         records = record
  15.                         key : integer;
  16.                         price : integer;
  17.                         stock : integer;
  18.                   end;
  19.  
  20.         ind = array [0..50] of index;
  21.  
  22. var
  23.         indrec : ind;
  24.         seqind : index;
  25.         indfile : file of index;
  26.         master : records;
  27.         masterfile : file of records;
  28.         exist, deleted, ender, valid : boolean;
  29.         norec, nextrec, recno, mid : integer;
  30.  
  31. procedure sortind (norec : integer);
  32. var
  33.         temp : index;
  34.         n : integer;
  35.  
  36. begin
  37.         n := norec;
  38.         if n > 1 then
  39.           while (indrec[n].reckey < indrec[n-1].reckey) and (n>1) do
  40.            begin
  41.              temp := indrec[n];
  42.              indrec[n] := indrec[n-1];
  43.              indrec[n-1] := temp;
  44.              n := n-1;
  45.            end;
  46. end;
  47.  
  48. procedure searchind (var norec, mid : integer ; keysrch : integer);
  49. var
  50.         low, high, digit : integer;
  51.         numbfnd : boolean;
  52. begin
  53.         low := 1;
  54.         high := norec;
  55.         numbfnd := false;
  56.  
  57.         repeat
  58.                 mid := (low + high) div 2;
  59.                 if keysrch < indrec[mid].reckey then
  60.                    high := mid - 1
  61.                 else
  62.                    if keysrch > indrec[mid].reckey then
  63.                       low := mid + 1
  64.                    else
  65.                       numbfnd := true;
  66.         until numbfnd or (low > high);
  67.  
  68.         if keysrch = indrec[mid].reckey then
  69.            exist := true
  70.         else
  71.            exist := false;
  72.  
  73.         if exist then
  74.            if indrec[mid].delflag then
  75.                 deleted := true
  76.            else
  77.                 deleted := false;
  78. end;
  79.  
  80. procedure copyin (var norec : integer);
  81. begin
  82.         norec := 1;
  83.         while not eof (indfile) do
  84.               begin
  85.                 read (indfile,seqind);
  86.                 indrec[norec] := seqind;
  87.                 norec := norec + 1;
  88.               end;
  89. end;
  90.  
  91. procedure copyout (norec : integer);
  92. var
  93.         n : integer;
  94. begin
  95.         rewrite (indfile);
  96.         n := 1;
  97.         while norec > n do
  98.           begin
  99.                 seqind := indrec[n];
  100.                 write (indfile, seqind);
  101.                 n := n + 1;
  102.           end;
  103. end;
  104.  
  105. procedure validkey (keysrch : integer);
  106. begin
  107.         if (keysrch > 0) and (keysrch < 1000) then
  108.            valid := true
  109.         else
  110.            valid := false;
  111. end;
  112.  
  113. procedure insertion (var norec : integer);
  114. var
  115.         srchkey, stkmnt, price, n : integer;
  116.         found : boolean;
  117.         ans : char;
  118. begin
  119.         clrscr;
  120.         textcolor (9);
  121.         writeln (` Please Enter The Key To Be Inserted. `);
  122.         writeln;
  123.         write (`KEY :- `);
  124.         readln (srchkey);
  125.         validkey (srchkey);
  126.         searchind (norec, mid, srchkey);
  127.         if norec < 5 then
  128.            begin
  129.                 while (exist and not deleted) and valid do
  130.                    begin
  131.                         textcolor (132);
  132.                         write (` THIS RECORD EXISTS. PLEASE RE-ENTER. `);
  133.                         writeln;
  134.                         textcolor (9);
  135.                         write (` KEY :- `);
  136.                         readln (srchkey);
  137.                         validkey (srchkey);
  138.                         searchind (norec, mid, srchkey);
  139.                    end;
  140.                 if not valid then
  141.                    begin
  142.                         textcolor (132);
  143.                         write (` THIS RECORD IS NOT VALID. PRESS ENTER. `);
  144.                         readln;
  145.                         insertion (norec);
  146.                    end;
  147.                 if deleted then
  148.                    begin
  149.                         textcolor (132);
  150.                         writeln (` THIS RECORD HAS BEEN DELETED `);
  151.                         writeln;
  152.                         writeln (` DO YOU WISH TO RE-USE THIS RECORD `);
  153.                         textcolor (4);
  154.                         write (` ( Y/N )? `);
  155.                         readln (ans);
  156.                         writeln;
  157.                         case ans of
  158.                            `Y`,`y` : begin
  159.                                       write (`PRICE :- `);readln (price);
  160.                                       write (`STOCK :- `);readln (stkmnt);
  161.                                       recno := indrec[mid].lorecno;
  162.                                       indrec[mid].delflag := false;
  163.                                       master.key := srchkey;
  164.                                       master.price := price;
  165.                                       master.stock := stkmnt;
  166.  
  167.                                       seek (masterfile, recno);
  168.                                       write (masterfile, master);
  169.                                      end;
  170.                         end;
  171.                    end
  172.                 else
  173.                    begin
  174.                         textcolor (9);
  175.                         writeln (` ENTER THE FOLLOWING `);
  176.                         writeln;
  177.                         write (` PRICE :- `); readln (price);
  178.                         writeln;
  179.                         write (` STOCK VALUE :- `); readln (stkmnt);
  180.  
  181.                         indrec[norec].reckey := srchkey;
  182.                         indrec[norec].lorecno := norec;
  183.                         indrec[norec].delflag := false;
  184.  
  185.                         master.key := srchkey;
  186.                         master.price := price;
  187.                         master.stock := stkmnt;
  188.  
  189.                         sortind (norec);
  190.                         seek (masterfile, norec);
  191.                         norec := norec + 1;
  192.                         nextrec := nextrec + 1;
  193.                         write (masterfile, master);
  194.                    end;
  195.                 end
  196.              else
  197.                 begin
  198.                      found := false;
  199.                      n := 1;
  200.                      while (norec > n) and not found do
  201.                       begin
  202.                         if indrec[n].delflag then
  203.                            begin
  204.                                 found := true;
  205.                                 recno := indrec[n].lorecno;
  206.                            end;
  207.                         n := n + 1;
  208.                       end;
  209.                      if found then
  210.                       begin
  211.                         n := n - 1;
  212.                         while norec > n do
  213.                            begin
  214.                                 indrec[n] := indrec[n + 1];
  215.                                 n := n + 1;
  216.                            end;
  217.                         textcolor (4);
  218.                         writeln;
  219.                         write (` PRICE :- `); readln (price);
  220.                         write (` STOCK :- `); readln (stkmnt);
  221.  
  222.                         master.key := srchkey;
  223.                         master.price := price;
  224.                         master.stock := stkmnt;
  225.                         seek (masterfile, recno);
  226.                         write ( masterfile, master);
  227.  
  228.                         indrec[norec-1].reckey := srchkey;
  229.                         indrec[norec-1].lorecno := recno;
  230.                         indrec[norec-1].delflag := false;
  231.  
  232.                         sortind (norec-1);
  233.                       end;
  234.  
  235.                      if (n = norec) and not found then
  236.                       begin
  237.                         textcolor (12);
  238.                         write (` THE INDEX IS FULL.`);
  239.                         writeln (`NO MORE RECORDS CAN BE SAVED. `);
  240.                         write (`PRESS ENTER. `);
  241.                         readln;
  242.                       end;
  243.            end;
  244. end;
  245.  
  246. procedure price (norec : integer);
  247. var
  248.         srchkey, prcch : integer;
  249. begin
  250.         clrscr;
  251.         textcolor (3);
  252.         writeln (`Please Enter The Key To Change The Price `);
  253.         write (` KEY :- `);
  254.         readln (srchkey);
  255.         validkey (srchkey);
  256.  
  257.         searchind (norec, mid, srchkey);
  258.         while (not exist or deleted) and valid do
  259.            begin
  260.                 textcolor (132);
  261.                 write (` THIS RECORD DOES NOT EXIST. PLEASE RE-ENTER. `);
  262.                 writeln;
  263.                 textcolor (3);
  264.                 write (` KEY :- `);
  265.                 readln (srchkey);
  266.                 validkey (srchkey);
  267.                 searchind (norec, mid, srchkey);
  268.            end;
  269.         if not valid then
  270.            begin
  271.                 textcolor (132);
  272.                 write (` THIS RECORD IS NOT VALID. PLEASE RE-ENTER. `);
  273.                 readln;
  274.                 price (norec);
  275.            end;
  276.  
  277.         recno := indrec[mid].lorecno;
  278.         textcolor (5);
  279.         writeln (` Please Enter The New Price `);
  280.         writeln;
  281.         write (` NEW PRICE :- `);
  282.         readln (prcch);
  283.         seek (masterfile, recno);
  284.         read (masterfile, master);
  285.         master.price := prcch;
  286.         seek (masterfile, recno);
  287.         write (masterfile, master);
  288. end;
  289.  
  290. procedure debit (norec : integer);
  291. var
  292.         srchkey, debmnt : integer;
  293. begin
  294.         clrscr;
  295.         textcolor (3);
  296.         writeln (` Please Enter Key To Be Debitted `);
  297.         write (` KEY :- `);
  298.         readln (srchkey);
  299.         validkey (srchkey);
  300.  
  301.         searchind (norec, mid, srchkey);
  302.         while (not exist or deleted) and valid do
  303.            begin
  304.                 textcolor (132);
  305.                 write (` THIS RECORD DOES NOT EXIST. PLEASE RE-ENTER. `);
  306.                 writeln;
  307.                 textcolor (3);
  308.                 write (` KEY :- `);
  309.                 readln (srchkey);
  310.                 validkey (srchkey);
  311.                 searchind (norec, mid, srchkey);
  312.            end;
  313.         if not valid then
  314.            begin
  315.                 textcolor (132);
  316.                 write (` THIS RECORD IS NOT VALID. PRESS ENTER. `);
  317.                 readln;
  318.                 debit (norec);
  319.            end;
  320.  
  321.         recno := indrec[mid].lorecno;
  322.         textcolor (5);
  323.         writeln (` Please Enter The Amount To Debit The Stock `);
  324.         writeln;
  325.         write (` DEBIT :- `);
  326.         readln (debmnt);
  327.         seek (masterfile, recno);
  328.         read (masterfile, master);
  329.         master.stock := master.stock - debmnt;
  330.         seek (masterfile, recno);
  331.         write (masterfile, master);
  332. end;
  333.  
  334. procedure erasure (var norec : integer);
  335. var
  336.         srchkey : integer;
  337.         ans : char;
  338. begin
  339.         clrscr;
  340.         textcolor (10);
  341.         writeln (` Please Enter The Key To Be Erased `);
  342.         writeln;
  343.         write (` KEY :- `);
  344.         readln (srchkey);
  345.         validkey (srchkey);
  346.         searchind (norec, mid, srchkey);
  347.         while (not exist or deleted) and valid do
  348.            begin
  349.                 textcolor (132);
  350.                 write (` THIS RECORD DOES NOT EXIST. PLEASE RE-ENTER. `);
  351.                 writeln;
  352.                 textcolor (9);
  353.                 write (` KEY :- `);
  354.                 readln (srchkey);
  355.                 validkey (srchkey);
  356.                 searchind (norec, mid, srchkey);
  357.            end;
  358.         if not valid then
  359.            begin
  360.                 textcolor (132);
  361.                 write ( THIS RECORD IS NOT VALID. PRESS ENTER. `);
  362.                 readln;
  363.                 erasure (norec);
  364.            end;
  365.         textcolor (10);
  366.         recno := indrec[mid].lorecno;
  367.         seek (masterfile, recno);
  368.         read (masterfile, master);
  369.         write (` KEY            :-      `);writeln (master.key);
  370.         write (` PRICE          :-      `);writeln (master.price);
  371.         write (` STOCK          :-      `);writeln )master.stock);
  372.         writeln;
  373.         textcolor (140);
  374.         write (`ARE YOU SURE  ????`);
  375.         textcolor (12);
  376.         write (`( Y/N )`);
  377.         readln (ans);
  378.         if (ans = `Y`) or (ans = `y`) then
  379.            begin
  380.                 indrec[mid[.delflag := true;
  381.                 writeln;
  382.                 textcolor (10); writeln (` RECORD DELETED `);
  383.            end;
  384. end;
  385.  
  386. procedure credit ( var norec : integer);
  387. var
  388.         srchkey, credmnt : integer;
  389. begin
  390.         clrscr;
  391.         textcolor (3);
  392.         writeln (` Please Enter The Key To Be Creditted `);
  393.         write (` KEY :- `);
  394.         readln (srchkey);
  395.         validkey (srchkey);
  396.         searchind (norec, mid, srchkey);
  397.         while (not exist or deleted) and valid do
  398.            begin
  399.                 textcolor (132);
  400.                 write (` THIS KEY DOES NOT EXIST. PLEASE RE-ENTER. `);
  401.                 writeln;
  402.                 textcolor (3);
  403.                 write (` KEY :- `);
  404.                 readln (srchkey);
  405.                 validkey (srchkey);
  406.                 searchind (norec, mid, srchkey);
  407.            end;
  408.         recno := indrec[mid].lorecno;
  409.         textcolor (5);
  410.         writeln (` Please Enter The Amount To Credit The Stock `);
  411.         writeln;
  412.         write (` CREDIT :- `);
  413.         readln (credmnt);
  414.         seek (masterfile, recno);
  415.         read (masterfile, master);
  416.         master.stock := master.stock + credmnt;
  417.         seek (masterfile, recno);
  418.         write (masterfile, master);
  419. end;
  420.  
  421. procedure viewrec (var norec : integer);
  422. var
  423.         srchkey : integer;
  424. begin
  425.         clrscr;
  426.         textcolor (3);
  427.         writeln (` ENTER RECORD KEY TO BE VIEWED `);
  428.         writeln;
  429.         write (` KEY :- `); readln (srchkey);
  430.         validkey (srchkey);
  431.         searchind (norec, mid, srchkey);
  432.         if exist and not deleted and valid then
  433.            begin
  434.                 recno := indrec[mid].lorecno;
  435.                 seek (masterfile, recno);
  436.                 read (masterfile, master);
  437.                 write (` KEY    :-   `);writeln (master.key);
  438.                 write (` PRICE  :-   `);writeln (master.price);
  439.                 write (` STOCK  :-   `);writeln (master.stock);
  440.                 writeln;
  441.                 writeln;
  442.                 write (` PLEASE PRESS ENTER  `);
  443.                 readln;
  444.            end
  445.         else
  446.            begin
  447.                 writeln (` THIS RECORD DOES NOT EXIST. PRESS ENTER `);
  448.                 readln;
  449.            end;
  450. end;
  451.  
  452. procedure viewindex (norec : integer);
  453. { THIS IS A HIDDEN FEATURE OF THE PROGRAM DESIGNED FOR TESTING.
  454.   BY ENTERING `T` ON THE MENU YOU WILL SEE THE CONTENTS OF THE INDEX.}
  455.  
  456. var
  457.         n, x : integer;
  458. begin
  459.         clrscr;
  460.         n := norec - 1;
  461.         writeln (`KEY    LO REC NO   DEL`);
  462.         while n > 0 do
  463.            begin
  464.                 x := norec - n;
  465.                 write (indrec[x].reckey,`      `);
  466.                 write (indrec[x].lorecno,`      `);
  467.                 writeln (indrec[x].delflag);
  468.                 n := n - 1;
  469.            end;
  470.         writeln;
  471.         writeln (` PRESS ENTER `);
  472.         readln;
  473. end;
  474.  
  475. procedure menu (var norec : integer);
  476. var
  477.         pckchr : char;
  478.         n : integer;
  479. begin
  480.         clrscr;
  481.         writeln;
  482.  
  483. textcolor(140);write(`       I`);textcolor(15);writeln(`nsert record.`);
  484. textcolor(140);write(`       C`);textcolor(15);writeln(`redit stock.`);
  485. textcolor(140);write(`       D`);textcolor(15);writeln(`ebit stock.`);
  486. textcolor(140);write(`       P`);textcolor(15);writeln(`rice change.`);
  487. textcolor(140);write(`       E`);textcolor(15);writeln(`rase record.`);
  488. textcolor(140);write(`       V`);textcolor(15);writeln(`iew record.`);
  489. textcolor(140);write(`       Q`);textcolor(15);writeln(`uit program.`);
  490.         writeln;
  491.         writeln;
  492.  
  493.         textcolor (3);
  494.         writeln (`  Please Select The Appropriate Flashing Letter !!!`);
  495.         readln (pckchr);
  496.  
  497.         case pckchr of
  498.  
  499.         `P` , `p` : price (norec);
  500.  
  501.         `C` , `c` : credit (norec);
  502.  
  503.         `D` , `d` : debit (norec);
  504.  
  505.         `E` , `e` : erasure (norec);
  506.  
  507.         `I` , `i` : insertion (norec);
  508.  
  509.         `V` , `v` : viewrec (norec);
  510.  
  511.         `T` , `t` : viewindex (norec);
  512.  
  513.         `Q` , `q` : ender := true;
  514.  
  515.         else
  516.                 menu (norec);
  517.         end;
  518.         if not ender then menu (norec);
  519. end;
  520.  
  521. begin { MAIN PROGGY }
  522.  
  523.         assign (masterfile, `masterfl.dat`);
  524.         reset (masterfile);
  525.  
  526.         assign (indfile, `index`);
  527.         reset (indfile);
  528.  
  529.         exist := false;
  530.         deleted := false;
  531.  
  532.         copyin (norec);
  533.  
  534.         ender := false;
  535.  
  536.         menu (norec);
  537.  
  538.         copyout (norec);
  539.  
  540.         close (masterfile);
  541.         close (indfile);
  542.  
  543. end.